use LWP::UserAgent;
use HTTP::Request;
-# curl -I behaviour: sends HEAD request, returns code
-sub head_code {
- my ($url) = @_;
-
- my $ua = LWP::UserAgent->new(max_redirect => 0);
- my $req = HTTP::Request->new('HEAD' => $url);
- my $res = $ua->request($req);
-
- return $res->code;
-}
-
-# curl -X behaviour: sends request with specified method, returns code
-sub request_code {
- my ($method, $url) = @_;
-
- my $ua = LWP::UserAgent->new(max_redirect => 0);
- my $req = HTTP::Request->new(uc($method) => $url);
- my $res = $ua->request($req);
-
- return $res->code;
-}
-
-# curl -X behaviour: sends request with specified method, returns body
-sub request_body {
+# curl -X behaviour: sends request with specified method, returns the full response
+sub do_request {
my ($method, $url) = @_;
my $ua = LWP::UserAgent->new(max_redirect => 0, timeout => 10);
my $req = HTTP::Request->new(uc($method) => $url);
- my $res = $ua->request($req);
-
- return $res->content;
+ return $ua->request($req);
}
sub teapot {
sub find_webmaster_email {
my ($url) = @_;
- my $body = request_body('GET', $url);
+ my $body = do_request('GET', $url)->content;
return undef unless $body;
if ($body =~ /mailto:([a-zA-Z0-9._%+\-]+\@[a-zA-Z0-9.\-]+\.[a-zA-Z]{2,})/i) { return $1 }
}
}
+sub good_manners {
+ my ($domain) = @_;
+
+ print "Your coffee is served. It's a good manner to refill the beans for others.\n";
+ print "Do you want to refill them now? (y/n)";
+ chomp(my $answer = <STDIN>);
+
+ if (lc($answer) eq 'y') {
+ do_request('POST', $domain);
+ print "\nBeans refilled. The pot is ready for the next brew.\n";
+ }
+}
+
## meat
# get the domain
die "error: This isn't valid url.\n";
}
-# check if user put www or not
+# check if user put www or not
if ($arg !~ /^www\./) {
my $dot_count = () = $arg =~ /\./g;
-
+
# ignore for subdomains
if ($dot_count < 2) {
$arg = "www." . $arg;
my $http_domain = "http://" . $arg;
my $https_domain = "https://" . $arg;
-my $http_brew = request_code('BREW', $http_domain);
-my $https_brew = request_code('BREW', $https_domain);
-my $http_tea = head_code($http_domain . "/teapot");
-my $https_tea = head_code($https_domain . "/teapot");
+# decision tree: one BREW per scheme, stop as soon as one works
+my $teapot_seen = 0;
-sub good_manners {
- my ($protocol) = @_;
-
- print "Your coffee is served. It's a good manner to refill the beans for others.\n";
- print "Do you want to refill them now? (y/n)";
- chomp(my $answer = <STDIN>);
+for my $domain ($http_domain, $https_domain) {
+ my $res = do_request('BREW', $domain);
- if (lc($answer) eq 'y') {
- if ($protocol eq 'http') {
- request_code('POST', $http_domain);
- print "\nBeans refilled. The pot is ready for the next brew.\n";
- }
- if ($protocol eq 'https') {
- request_code('POST', $https_domain);
- print "\nBeans refilled. The pot is ready for the next brew.\n";
- }
+ if ($res->code == 200) {
+ print $res->content, "\n";
+ good_manners($domain);
+ exit;
}
+ $teapot_seen = 1 if $res->code == 418;
}
-# decision tree
-if ($http_brew == 200) {
- print request_body('BREW', $http_domain);print "\n";
- good_manners('http');
-} elsif ($https_brew == 200) {
- print request_body('BREW', $https_domain);print "\n";
- good_manners('https');
-} elsif ($http_brew == 418 || $https_brew == 418) {
- teapot();
-} elsif ($http_tea == 200 || $https_tea == 200) {
+if ($teapot_seen) {
teapot();
-} else {
- no_coffee();
+ exit;
}
+# no BREW worked: check for a /teapot page
+for my $domain ($http_domain, $https_domain) {
+ if (do_request('HEAD', "$domain/teapot")->code == 200) {
+ teapot();
+ exit;
+ }
+}
+
+no_coffee($arg);
+
#print "\nThank you for using the htcpcp requestor.\n";
## debuging
-# print head_code($http_domain); print "\n";
-# print request_code('BREW', $http_domain); print "\n";
+# print do_request('HEAD', $http_domain)->code; print "\n";
+# print do_request('BREW', $http_domain)->code; print "\n";
-# print head_code($https_domain); print "\n";
-# print request_code('BREW', $https_domain); print "\n";
+# print do_request('HEAD', $https_domain)->code; print "\n";
+# print do_request('BREW', $https_domain)->code; print "\n";